home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / brklyprl.lha / Emulator / Tests / e.pl < prev    next >
Encoding:
Text File  |  1989-04-14  |  9.1 KB  |  312 lines
  1.  
  2. /* Copyright (C) 1988, 1989 Herve' Touati, Aquarius Project, UC Berkeley */
  3.  
  4. /* Copyright Herve' Touati, Aquarius Project, UC Berkeley */
  5.  
  6. /**** TEST PROGRAM ****/
  7.  
  8.  
  9. /* A Graph Reducer for T-Combinators:
  10.   Reduces a T-combinator expression to
  11.   a final answer.  Recognizes the
  12.   combinators I,K,S,B,C,S',B',C', cond, apply,
  13.   arithmetic, tests, basic list operations,
  14.   function definitions in the data base
  15.   stored as facts of the form
  16.   t_def(_func, _args, _expr). */
  17.  
  18.  
  19. /* Do test: */
  20. /* (This predicate contains the only write statements in this file) */
  21. main :-
  22.     try(quick([3,1,2]), _ans2),
  23.     write(_ans2), nl.
  24.  
  25. try(_inpexpr, _anslist) :-
  26.     listify(_inpexpr, _list),
  27.     curry(_list, _curry),
  28.     t_reduce(_curry, _ans),
  29.     make_list(_ans, _anslist).
  30.  
  31.  
  32. /*********************************************************************/
  33. /* Examples of applicative functions which can be compiled & executed */
  34. /* This test version compiles them just before each execution */
  35.  
  36. t_def(fac, [N], cond(N=0, 1, N*fac(N-1))).
  37.  
  38. t_def(gcd, [_a,_b], cond(_b=0, _a, gcd(_b, _a mod _b))).
  39.  
  40. /* List operations: */
  41.  
  42. t_def(last, [_l], cond(tl(_l)=[], hd(_l), last(tl(_l)))).
  43. t_def(reverse, [_l], rev(_l,[])).
  44. t_def(rev, [_a,_s], cond(_a=[],_s,rev(tl(_a),[hd(_a)|_s]))).
  45.  
  46. /* Quicksort in purely applicative form */
  47.  
  48. t_def(quick, [_l], cond(_l=[], [],
  49.          cond(tl(_l)=[], _l,
  50.          quick2(split(hd(_l),tl(_l)))))).
  51. t_def(quick2, [_l], append(quick(hd(_l)), quick(tl(_l)))).
  52.  
  53. t_def(split, [_e,_l], cond(_l=[], [[_e]|[]],
  54.             cond(hd(_l)=<_e, inserthead(hd(_l),split(_e,tl(_l))),
  55.             inserttail(hd(_l),split(_e,tl(_l)))))).
  56. t_def(inserthead, [_e,_l], [[_e|hd(_l)]|tl(_l)]).
  57. t_def(inserttail, [_e,_l], [hd(_l)|[_e|tl(_l)]]).
  58.  
  59. t_def(append, [_a,_b], cond(_a=[], _b, [hd(_a)|append(tl(_a),_b)])).
  60.  
  61. /**************************************************************************/
  62.  
  63. /* Full reduction: */
  64.  
  65. t_reduce(_expr, _ans) :-
  66.     atomic(_expr), !, _ans=_expr.
  67. /* The reduction of '.' must be here to avoid an infinite loop */
  68. t_reduce([_y,_x|'.'], [_yr,_xr|'.']) :-
  69.     t_reduce(_x, _xr),
  70.     t_reduce(_y, _yr), !.
  71. t_reduce(_expr, _ans) :-
  72.     t_append(_next-_red, _form, _expr),
  73.     t_redex(_form, _red), !,
  74.     t_reduce(_next, _ans), !.
  75.  
  76. t_append(_link-_link,_l,_l).
  77. t_append([_a|_l1]-_link, _l2, [_a|_l3]) :- t_append(_l1-_link, _l2, _l3).
  78.  
  79. /* One Step reduction: */
  80.  
  81. /* combinators: */
  82. t_redex([_x,_g,_f,_k|sp], [[_xr|_g],[_xr|_f]|_k]) :- t_reduce(_x, _xr).
  83. t_redex([_x,_g,_f,_k|bp], [[_x|_g],_f|_k]).
  84. t_redex([_x,_g,_f,_k|cp], [_g,[_x|_f]|_k]).
  85. t_redex([_x,_g,_f|s], [[_xr|_g]|[_xr|_f]]) :- t_reduce(_x, _xr).
  86. t_redex([_x,_g,_f|b], [[_x|_g]|_f]).
  87. t_redex([_x,_g,_f|c], [_g,_x|_f]).
  88. t_redex([_y,_x|k], _x).
  89. t_redex([_x|i], _x).
  90.  
  91. /* conditional: */
  92. t_redex([_elsepart,_ifpart,_cond|cond], _ifpart) :-
  93.     t_reduce(_cond, _bool), _bool=true, !.
  94.     /* Does NOT work if _bool is substituted in the call! */
  95. t_redex([_elsepart,_ifpart,_cond|cond], _elsepart).
  96.  
  97. /* apply: */
  98. t_redex([_f|apply], _fr) :- t_reduce(_f, _fr).
  99.  
  100. /* list operations: */
  101. t_redex([_arg|hd], _x) :- t_reduce(_arg, [_y,_x|'.']).
  102. t_redex([_arg|tl], _y) :- t_reduce(_arg, [_y,_x|'.']).
  103.  
  104. /* arithmetic: */
  105. t_redex([_y,_x|_op], _res) :-
  106.     atom(_op),
  107.     member(_op, ['+', '-', '*', '/', 'mod']),
  108.     t_reduce(_x, _xres),
  109.     t_reduce(_y, _yres),
  110.     number(_xres), number(_yres),
  111.     _t=..[_op,_xres,_yres],
  112.     _res is _t.
  113.  
  114. /* tests: */
  115. t_redex([_y,_x|_test], _res) :-
  116.     atom(_test),
  117.     member(_test, ['<', '>', '=<', '>=', '\==']),
  118.     t_reduce(_x, _xres),
  119.     t_reduce(_y, _yres),
  120.     number(_xres), number(_yres),
  121.     _t=..[_test,_xres,_yres],
  122.     (call(_t) -> _res=true; _res=false), !.
  123.  
  124. /* equality */
  125. t_redex([_y,_x|=], _res) :-
  126.     t_reduce(_x, _xres),
  127.     t_reduce(_y, _yres),
  128.     (_xres=_yres -> _res=true; _res=false), !.
  129.  
  130. /* built-in functions: */
  131. t_redex([_x|_op], _res) :-
  132.     atom(_op),
  133.     member(_op, ['-', round, trunc]),
  134.     t_reduce(_x, _xres),
  135.     number(_xres),
  136.     _t=..[_op,_xres],
  137.     _res is _t.
  138.  
  139. /* definitions:
  140.   Assumes a fact t_def(_func,_def) in the database for every
  141.   defined function. */
  142. t_redex(_in, _out) :-
  143.     append(_par,_func,_in),
  144.     atom(_func),
  145.     t_def(_func, _args, _expr),
  146.     t(_args, _expr, _def),
  147.     append(_par,_def,_out).
  148.  
  149.  
  150. /* Utility to convert curried list into regular list: */
  151. make_list(_a, _a) :- atomic(_a).
  152. make_list([_b,_a|'.'], [_a|_rb]) :- make_list(_b, _rb).
  153.  
  154.  
  155. listify(_X, _X) :- 
  156.     (var(_X); atomic(_X)), !.
  157. listify(_Expr, [_Op|_LArgs]) :-
  158.     _Expr=..[_Op|_Args],
  159.     listify_list(_Args, _LArgs).
  160.  
  161. listify_list([], []).
  162. listify_list([_A|_Args], [_LA|_LArgs]) :-
  163.     listify(_A, _LA),
  164.     listify_list(_Args, _LArgs).
  165.  
  166. member(X, [X|_]).
  167. member(X, [_|L]) :- member(X, L).
  168.  
  169. append([], L, L).
  170. append([X|L1], L2, [X|L3]) :- append(L1, L2, L3).
  171.  
  172. /***************************************************************************/
  173. /* Scheme T:
  174.   A Translation Scheme for T-Combinators
  175. */
  176. /* :- alldynamic. */
  177.  
  178. /* translate an expression to combinator form
  179.   by abstracting out all variables in _argvars: */
  180. t(_argvars, _expr, _trans) :-
  181.     listify(_expr, _list),
  182.     curry(_list, _curry),
  183.     t_argvars(_argvars, _curry, _trans), !.
  184.  
  185. t_argvars([], _trans, _trans).
  186. t_argvars([_x|_argvars], _in, _trans) :-
  187.     t_argvars(_argvars, _in, _mid),
  188.     t_vars(_mid, _vars), /*calculate variables in each subexpression*/
  189.     t_trans(_x, _mid, _vars, _trans). /*main translation routine*/
  190.  
  191. /* Curry the original expression:
  192.   This converts an applicative expression of any number
  193.   of arguments and any depth of nesting into an expression
  194.   where all functions are curried, i.e. all function
  195.   applications are to one argument and have the form
  196.   [_arg|_func] where _func & _arg are also of that form.
  197.   Input is a nested function application in list form.
  198.   Currying makes t_trans faster. */
  199. curry(_a, _a) :- (var(_a); atomic(_a)), !.
  200. curry([_func|_args], _cargs) :-
  201.     currylist(_args, _cargs-_func).
  202.  
  203. /* Transform [_a1, ..., _aN] to [_cN, ..., _c1|_link]-_link */
  204. currylist([], _link-_link) :- !.
  205. currylist([_a|_args], _cargs-_link) :-
  206.     curry(_a, _c),
  207.     currylist(_args, _cargs-[_c|_link]).
  208.  
  209. /* Calculate variables in each subexpression:
  210.   To any expression a list of the form
  211.   [_vexpr, _astr, _fstr] is matched.
  212.   If the expression is a variable or an atom
  213.   then this list only has the first element.
  214.   _vexpr = List of all variables in the expression.
  215.   _astr, _fstr = Similar structures for argument & function. */
  216. t_vars(_v, [[_v]]) :- var(_v), !.
  217. t_vars(_a, [[]]) :- atomic(_a), !.
  218. t_vars([_func], [[]]) :- atomic(_func), !.
  219. t_vars([_arg|_func], [_g,[_g1|_af1],[_g2|_af2]]) :-
  220.     t_vars(_arg, [_g1|_af1]),
  221.     t_vars(_func, [_g2|_af2]),
  222.     unionv(_g1, _g2, _g).
  223.  
  224. /* The main translation routine:
  225.   trans(_var, _curriedexpr, _varexpr, _result) */
  226. /* The translation scheme T in the article is followed literally. */
  227. /* A good example of Prolog as a specification language. */
  228. t_trans(_x, _a, _, [_a|k]) :- (atomic(_a); var(_a), _a\==_x), !.
  229. t_trans(_x, _y, _, i) :- _x==_y, !.
  230. t_trans(_x, _e, [_ve|_], [_e|k]) :- notin(_x, _ve).
  231. t_trans(_x, [_f|_e], [_vef,_sf,_se], _res) :-
  232.     _sf=[_vf|_],
  233.     _se=[_ve|_other],
  234.     (atom(_e); _other=[_,[_ve1|_]], _ve1\==[]),
  235.     t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, _res).
  236. t_trans(_x, [_g|[_f|_e]], [_vefg,_sg,_sef], _res) :-
  237.     _sg=[_vg|_],
  238.     _sef=[_vef,_sf,_se],
  239.     _se=[_ve|_],
  240.     _sf=[_vf|_],
  241.     t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, _res).
  242.  
  243. /* First complex rule of translation scheme T: */
  244. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, _e) :-
  245.     notin(_x, _ve), _x==_f, !.
  246. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_resf,_e|b]) :-
  247.     notin(_x, _ve), in(_x, _vf), _x\==_f, !,
  248.     t_trans(_x, _f, _sf, _resf).
  249. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_f,_rese|c]) :-
  250.     /* in(_x, _ve), */ notin(_x, _vf), !,
  251.     t_trans(_x, _e, _se, _rese).
  252. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_resf,_rese|s]) :-
  253.     /* in(_x, _ve), in(_x, _vf), */
  254.     t_trans(_x, _e, _se, _rese),
  255.     t_trans(_x, _f, _sf, _resf).
  256.  
  257. /* Second complex rule of translation scheme T: */
  258. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_g,_e|c]) :-
  259.     _x==_f, notin(_x, _vg), !.
  260. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_e|s]) :-
  261.     _x==_f, /* in(_x, _vg), */ !,
  262.     t_trans(_x, _g, _sg, _resg).
  263. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_g,_resf,_e|cp]) :-
  264.     /* _x\==_f, */ in(_x, _vf), notin(_x, _vg), !,
  265.     t_trans(_x, _f, _sf, _resf).
  266. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_resf,_e|sp]) :-
  267.     /* _x\==_f, */ in(_x, _vf), /* in(_x, _vg), */ !,
  268.     t_trans(_x, _f, _sf, _resf),
  269.     t_trans(_x, _g, _sg, _resg).
  270. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_f|_e]) :-
  271.     /* notin(_x, _vf), */ _x==_g, !.
  272. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_f,_e|bp]) :-
  273.     /* notin(_x, _vf), in(_x, _vg), _x\==_g, */
  274.     t_trans(_x, _g, _sg, _resg).
  275.  
  276.  
  277. /* Set utilities */
  278. memberv(X, [Y|_]) :- X==Y, !.
  279. memberv(X, [_|L]) :- memberv(X, L).
  280.  
  281. in(X, L) :- memberv(X, L).
  282. notin(X, L) :- memberv(X, L), !, fail.
  283. notin(X, L).
  284.  
  285. unionv(S1, S2, S1) :- S1==S2.
  286. unionv([X|S1], S2, Res) :-
  287.     memberv(X, S2), !,
  288.     unionv(S1, S2, Res).
  289. unionv([X|S1], S2, [X|Res]) :-
  290.     unionv(S1, S2, Res).
  291. unionv([], S, S).
  292.  
  293. diffv([X|S1], S2, Res) :-
  294.     memberv(X, S2), !,
  295.     diffv(S1, S2, Res).
  296. diffv([X|S1], S2, [X|Res]) :-
  297.     diffv(S1, S2, Res).
  298. diffv([], _, []).
  299.  
  300. intersectv([X|Set1], Set2, Res) :-
  301.     (in(X,Set1); notin(X, Set2)), !,
  302.     intersectv(Set1, Set2, Res).
  303. intersectv([X|Set1], Set2, [X|Res]) :-
  304.     intersectv(Set1, Set2, Res).
  305. intersectv([], _, []).
  306.  
  307. subsetv([], _).
  308. subsetv([X|Set1], Set2) :-
  309.     memberv(X, Set2),
  310.     subsetv(Set1, Set2).
  311.  
  312.